home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / type.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  61KB  |  1,867 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "attr.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "axqrp.h"
  20. #include "setp.h"
  21. #include "dbxp.h"
  22. #include "initobjp.h"
  23. #include "maincasp.h"
  24. #include "gmainp.h"
  25. #include "arithp.h"
  26. #include "segmentp.h"
  27. #include "genp.h"
  28. #include "exprp.h"
  29. #include "gutilp.h"
  30. #include "arithp.h"
  31. #include "genp.h"
  32. #include "miscp.h"
  33. #include "gmiscp.h"
  34. #include "smiscp.h"
  35. #include "statp.h"
  36. #include "typep.h"
  37.  
  38. static void init_enum(Symbol, Segment, int, int);
  39. static void install_type(Symbol, Segment, int);
  40. static Segment make_fixed_template(Const, Const, Const, Const,
  41.   struct tt_fx_range **);
  42. static void split_powers(int *);
  43. static void process_record(Symbol);
  44. static int linearize_record(Tuple, Node);
  45. static int discr_dep_subtype(Node);
  46. static void get_discr(Node, int *, int *);
  47. static void eval_max_size(Symbol, Tuple);
  48.  
  49. #define TT_PTR(p) (int **) p
  50. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  51. extern Segment   VARIANT_TABLE, FIELD_TABLE;
  52.  
  53. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  54. extern *ADA_MIN_INTEGER_MP, *ADA_MAX_INTEGER_MP;
  55. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  56. extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  57.  
  58. static char  *PRECISION_NOT_SUPPORTED = 
  59.   "Precision not supported by implementation. (Appendix F)";
  60. /* split_ variables use to report result from split_powers()*/
  61. static int split_powers_2, split_powers_5, split_powers_value;
  62.  
  63. /* Chapter 3: types */
  64. /* type elaboration */
  65.  
  66. void gen_type(Symbol type_name)                                    /*;gen_type*/
  67. {
  68.     /* This is the main procedure for type elaboration.
  69.      *
  70.      *   type_name : in the case of a type declaration, this is the
  71.      *               name of the type.
  72.      */
  73.  
  74.     Node l_node, u_node, d_node, s_node, low_node, high_node, entry_node;
  75.     Node name_node, pragma_id, pragma_list, pragma_op, pragma_val, value_node;
  76.     Symbol parent_type, comp_type, typ, entry_name, entry_type, index;
  77.     Symbol indx_type, task_proc;
  78.     Tuple type_list, index_list, tup, sig, entry_list;
  79.     int  nb_dim, lng, priority, offset;
  80.     long nb_elements, nb_len;    /* long to avoid overflow problems */
  81.     int family_number, len, global_flag, ubd, lbd;
  82.     int        collection_size;
  83.     Tuple    repr_tup;
  84.     Const low_const, high_const, delta_const, small_const;
  85.     Segment stemplate, static_template, non_static_template;
  86.     Fortup ft1;
  87.     struct tt_array *tt_array_ptr;
  88.     struct tt_e_range  *tt_e_range_ptr;
  89.     struct tt_access   *tt_access_ptr;
  90.     struct tt_task *tt_task_ptr;
  91.     struct tt_fx_range *tt_fx_range_ptr;
  92.  
  93. #ifdef TRACE
  94.     if (debug_flag)
  95.         gen_trace_symbol("GEN_TYPE", type_name);
  96. #endif
  97.  
  98.     switch(NATURE(type_name)) {
  99.  
  100.     case(na_type):
  101.         /* Case of FIXED types for which we create a template.
  102.          *  Also case of derived types.
  103.          */
  104.         if (is_fixed_type(type_name)) {
  105.             sig = SIGNATURE(type_name);
  106.             l_node = (Node) sig[2];
  107.             u_node = (Node) sig[3];
  108.             d_node = (Node) sig[4];
  109.             s_node = (Node) sig[5];
  110.  
  111.             low_const = get_ivalue(l_node);
  112.             high_const = get_ivalue(u_node);
  113.             delta_const = get_ivalue(d_node);
  114.             small_const = get_ivalue(s_node);
  115.             stemplate = make_fixed_template(low_const, high_const, delta_const,
  116.               small_const, &tt_fx_range_ptr);
  117.             /* SETL ver supports 2 kinds of fixed point, in C we have only 1 */
  118.             tt_fx_range_ptr->fxlow = ADA_MIN_FIXED + 1;
  119.             tt_fx_range_ptr->fxhigh = ADA_MAX_FIXED;
  120.             TYPE_KIND(type_name) = TK_LONG;
  121.             TYPE_SIZE(type_name) = su_size(TK_LONG);
  122.  
  123.             install_type(type_name, stemplate, TRUE);
  124.             root_type(type_name) = type_name;
  125.         }
  126.         else {        /* Derived type */
  127.             parent_type = TYPE_OF(type_name);
  128.             assign_same_reference(type_name, parent_type);
  129.             TYPE_KIND(type_name) = TYPE_KIND(parent_type);
  130.             TYPE_SIZE(type_name) = TYPE_SIZE(parent_type);
  131.         }
  132.         break;
  133.  
  134.     case(na_array):
  135.         tup = (Tuple) SIGNATURE(type_name);
  136.         index_list = (Tuple) tup[1];
  137.         comp_type = (Symbol) tup[2];
  138.         if (is_entry_type(comp_type))
  139.             return;
  140.         nb_dim = tup_size(index_list);
  141.         nb_elements = 1L;
  142.         FORTUP(index = (Symbol), index_list, ft1);
  143.             len = length_of(index);
  144.             if (len >= 0)
  145.                 nb_elements *= len;
  146.             else
  147.                 nb_elements = -1L;
  148.         ENDFORTUP(ft1);
  149.         if ((nb_elements >= 0L) && has_static_size(comp_type)) {
  150.             /* want TYPE_SIZE to be number of storage units for array , */
  151.             /* TBSL: check that TYPE_KIND assignment below right,
  152.               * as in SETL just have TYPE_SIZE assignment of course 
  153.               */
  154.             TYPE_KIND(type_name) = TYPE_KIND(comp_type);
  155.             nb_len= nb_elements * TYPE_SIZE(comp_type);
  156.             if (nb_len > MAX_STATIC_SIZE) nb_len = -1;
  157.             TYPE_SIZE(type_name) = nb_len;
  158.         }
  159.         else {
  160.             TYPE_SIZE(type_name) = -1;
  161.         }
  162.         stemplate = template_new(TT_U_ARRAY, size_of(type_name),
  163.           WORDS_ARRAY - 4, TT_PTR(&tt_array_ptr));
  164.         /* TBSL: need to define field TT_U_ARRAY_DIMENSIONS: byte or integer? */
  165.         tt_array_ptr->dim = nb_dim;
  166.         global_flag = has_static_size(type_name);
  167.         type_list = tup_copy(index_list);
  168.         type_list = (Tuple) tup_with(type_list, (char *) comp_type);
  169.         while(tup_size(type_list)) {
  170.             typ = (Symbol) tup_frome(type_list);
  171.             reference_of(typ);
  172.             /* template      +:= ref; */
  173.             segment_put_int(stemplate, REFERENCE_SEGMENT);
  174.             segment_put_int(stemplate, (int) REFERENCE_OFFSET);
  175.             global_flag &= is_global(typ);
  176.         }
  177.         tup_free(type_list);
  178.         install_type(type_name, stemplate, global_flag);
  179.         break;
  180.  
  181.     case(na_record):
  182.         process_record(type_name);
  183.         break;
  184.  
  185.     case(na_enum):
  186.         /* this one is certainly static... */
  187.         sig = SIGNATURE(type_name);
  188.         low_node = (Node) sig[2];
  189.         high_node = (Node) sig[3];
  190.         lbd = get_ivalue_int(low_node);
  191.         ubd = get_ivalue_int(high_node);
  192.         stemplate = template_new(TT_ENUM, 1, WORDS_E_RANGE, 
  193.           TT_PTR(&tt_e_range_ptr));
  194.         tt_e_range_ptr->elow = lbd;
  195.         tt_e_range_ptr->ehigh = ubd;
  196.         init_enum(type_name, stemplate, lbd, ubd);
  197.         /* TYPE_SIZE(type_name) = ubd <= 255 ? mu_size(mu_byte) :
  198.           mu_size(mu_word); */
  199.         TYPE_KIND(type_name) = TK_WORD; /* only word case for 1st version */
  200.         TYPE_SIZE(type_name) = 1; /* only word case for 1st version ds*/
  201.         /* put that in the static segment.... */
  202.         install_type(type_name, stemplate, TRUE);
  203.         break;
  204.  
  205.     case(na_access):
  206.         /* Needs own template, as the accessed type contains a task
  207.          * (otherwise expander changed it to derived type from $ACCESS).
  208.          */
  209.         TYPE_KIND(type_name) = TYPE_KIND(symbol_daccess);
  210.         TYPE_SIZE(type_name) = TYPE_SIZE(symbol_daccess);
  211.         stemplate = template_new(TT_ACCESS, size_of(type_name),
  212.           WORDS_ACCESS, TT_PTR(&tt_access_ptr));
  213.         tt_access_ptr->master_task = 0;
  214.         tt_access_ptr->master_bfp = 0;
  215.         repr_tup = REPR(type_name);
  216.         if (repr_tup == (Tuple)0)         /* error condition */
  217.             value_node = OPT_NODE;
  218.         else 
  219.             value_node = (Node) repr_tup[3];
  220.         if (N_KIND(value_node) == as_opt) {
  221.            tt_access_ptr->collection_size = ADA_MAX_INTEGER;
  222.            tt_access_ptr->collection_avail = ADA_MAX_INTEGER;
  223.         }
  224.         else if (N_KIND(value_node) == as_ivalue) {
  225.            collection_size = INTV((Const)N_VAL(value_node));
  226.            tt_access_ptr->collection_size = collection_size;
  227.            tt_access_ptr->collection_avail = collection_size;
  228.         }
  229.         install_type(type_name, stemplate, FALSE);
  230.         if ((N_KIND(value_node) != as_opt) && 
  231.             (N_KIND(value_node) != as_ivalue)) {
  232.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  233.            gen_kic(I_ADD_IMMEDIATE, mu_word, 
  234.                    WORD_OFF(tt_access, collection_size), "collection size");
  235.            gen_value(value_node);
  236.            gen_kc(I_MOVE, mu_word, "update collection size");
  237.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  238.            gen_kic(I_ADD_IMMEDIATE, mu_word, 
  239.                    WORD_OFF(tt_access, collection_avail), "collection avail");
  240.            gen_value(value_node);
  241.            gen_kc(I_MOVE, mu_word, "update collection avail");
  242.         }
  243.         break;
  244.  
  245.     case(na_task_type_spec):
  246.     case(na_task_type):
  247.         entry_list = SIGNATURE(type_name);
  248.         priority = MAX_PRIO-2;
  249.         TYPE_KIND(type_name) = TK_WORD;/* SETL has '2' for this size */
  250.         TYPE_SIZE(type_name) = su_size(TK_WORD);
  251.         /* SETL has '2' for this size */
  252.         global_flag = TRUE;
  253.         offset = 0;
  254.         family_number = 0;
  255.         static_template = segment_new(SEGMENT_KIND_DATA, 4);
  256.         non_static_template = segment_new(SEGMENT_KIND_DATA, 4);
  257.         
  258.         FORTUP(entry_node = (Node), entry_list, ft1);
  259.             if (N_KIND(entry_node) == as_line_no) {
  260.                 ;
  261.             }
  262.             else if (N_KIND(entry_node) == as_pragma) {
  263.                 pragma_id = N_AST1(entry_node);
  264.                 pragma_list = N_AST2(entry_node);
  265.                 if (streq(N_VAL(pragma_id), "priority")) {
  266.                     pragma_op = (Node) N_LIST(pragma_list)[1];
  267.                     pragma_val = N_AST2(pragma_op);
  268.                     priority = (int) N_VAL(pragma_val);
  269.                 }
  270.             }
  271.             else {
  272.                 family_number += 1;
  273.                 name_node = N_AST1(entry_node);
  274.                 entry_name = N_UNQ(name_node);
  275.                 S_SEGMENT(entry_name) = 0;
  276.                 S_OFFSET(entry_name) = family_number;
  277.                 /* TBSL: do we need set TYPE_KIND here (think not) ds 8-14-85 */
  278.                 TYPE_SIZE(entry_name) = size_entry(entry_name);
  279.                 if (N_KIND(entry_node) == as_entry_family) {
  280.                     entry_type = TYPE_OF(entry_name);
  281.                     /* [[indx_type], -] := SIGNATURE(entry_type); */
  282.                     tup = (Tuple) SIGNATURE(entry_type);
  283.                     tup = (Tuple) tup[1];
  284.                     indx_type = (Symbol) tup[1];
  285.                     reference_of(indx_type);
  286.                     global_flag &= is_static_type(indx_type);
  287.                     if (global_flag) {
  288.                         lng = length_of(indx_type);
  289.                         low_node = (Node) SIGNATURE(indx_type)[2];
  290.                         /*  static_template 
  291.                          *    +:= [offset-get_ivalue(low_node), lng];
  292.                          */
  293.                         segment_put_word(static_template,
  294.                           offset - get_ivalue_int(low_node));
  295.                         segment_put_word(static_template, lng);
  296.                         offset += lng;
  297.                     }
  298.                     /* non_static_template +:= ref; */
  299.                     segment_put_word(non_static_template, REFERENCE_SEGMENT);
  300.                     segment_put_word(non_static_template,
  301.                       (int) REFERENCE_OFFSET);
  302.                 }
  303.                 else {
  304.                     /* static_template     +:= [offset, 1]; */
  305.                     segment_put_word(static_template, offset);
  306.                     segment_put_word(static_template, 1);
  307.                     offset += 1;
  308.                     /* non_static_template +:= [0, 0]; */
  309.                     segment_put_word(non_static_template, 0);
  310.                     segment_put_word(non_static_template, 0);
  311.                 }
  312.             }
  313.         ENDFORTUP(ft1);
  314.  
  315.         /* This may be a derived type */
  316.         parent_type = TYPE_OF(type_name);
  317.         task_proc = assoc_symbol_get(parent_type, TASK_INIT_PROC);
  318.         global_flag &= is_global(task_proc);
  319.  
  320.         stemplate = template_new(TT_TASK, 1, WORDS_TASK, TT_PTR(&tt_task_ptr));
  321.         tt_task_ptr->priority = priority;
  322.         reference_of(task_proc);
  323.         tt_task_ptr->body_base = REFERENCE_SEGMENT;
  324.         tt_task_ptr->body_off = REFERENCE_OFFSET;
  325.         tt_task_ptr->nb_entries = offset;
  326.         tt_task_ptr->nb_families = family_number;
  327. #ifdef MONITOR
  328. #define NAMESIZE  119
  329.         {
  330.         int length;
  331.         static FILE *fp = NULL;
  332.         static char source_file[NAMESIZE];
  333.         if (strncmp( ORIG_NAME(type_name), "task_type:", 10 ))
  334.         {
  335.             length = strlen( ORIG_NAME(type_name));
  336.             strncpy( tt_task_ptr->task_name, ORIG_NAME(type_name),
  337.                     length);
  338.         }
  339.         else
  340.         {
  341.             length = strchr( ORIG_NAME(type_name), 'n' ) 
  342.                 - ORIG_NAME(type_name) - 10;
  343.             strncpy( tt_task_ptr->task_name, 
  344.                 ORIG_NAME(type_name)+10, length);
  345.             tt_task_ptr->task_name[length] = '\0';
  346.         }
  347.         if ( fp == NULL )
  348.         {
  349.             fp = fopen( "CWKLIB.$$$", "r" );
  350.             if ( fp == NULL )
  351.             {
  352.                 fprintf(stderr, "Cannot open CWKLIB\n");
  353.             }
  354.             fgets( source_file, NAMESIZE, fp );
  355.             length = strlen(source_file) - 1;
  356.             source_file[length] = '\0';
  357.         }
  358.         strcpy(tt_task_ptr->task_file, source_file);
  359.         }
  360. #undef NAMESIZE
  361. #endif
  362.         repr_tup = REPR(type_name);
  363.         if (repr_tup == (Tuple)0)         /* error condition */
  364.             value_node = OPT_NODE;
  365.         else
  366.             value_node = (Node) repr_tup[3];
  367.         if (N_KIND(value_node) == as_opt) {
  368.            tt_task_ptr->collection_size = ADA_MAX_INTEGER;
  369.            tt_task_ptr->collection_avail = ADA_MAX_INTEGER;
  370.         }
  371.         else if (N_KIND(value_node) == as_ivalue) {
  372.            collection_size = INTV((Const)N_VAL(value_node));
  373.            tt_task_ptr->collection_size = collection_size;
  374.            tt_task_ptr->collection_avail = collection_size;
  375.         }
  376.  
  377.         if (global_flag) {
  378.             /* template +:= static_template; */
  379.             segment_append(stemplate, static_template);
  380.         }
  381.         else {
  382.             /* template +:= non_static_template; */
  383.             segment_append(stemplate, non_static_template);
  384.             /* TBSL: see if static_template and non_static template can be free
  385.            here */
  386.         }
  387.  
  388.         install_type(type_name, stemplate, global_flag);
  389.         if ((N_KIND(value_node) != as_opt) &&
  390.             (N_KIND(value_node) != as_ivalue)) {
  391.            gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  392.            gen_kic(I_ADD_IMMEDIATE, mu_word,
  393.                    WORD_OFF(tt_task, collection_size), "collection size");
  394.            gen_value(value_node);
  395.            gen_kc(I_MOVE, mu_word, "update collection size");
  396.            gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  397.            gen_kic(I_ADD_IMMEDIATE, mu_word,
  398.                    WORD_OFF(tt_task, collection_avail), "collection avail");
  399.            gen_value(value_node);
  400.            gen_kc(I_MOVE, mu_word, "update collection avail");
  401.         }
  402.  
  403.         break;
  404.  
  405.     case(na_entry):
  406.     case(na_entry_former):
  407.         break;
  408.  
  409.     default:
  410.         compiler_error_s("Unexpected type nature: ", type_name);
  411.     }
  412. }
  413.  
  414. static void init_enum(Symbol type_name, Segment stemplate, int lbd, int ubd)
  415.                                                                 /*;init_enum*/
  416. {
  417.     /* initialize enumeration map values in segment.
  418.      * the literal map is a tuple with pairs of values giving the string
  419.      * and the value. For C version we put values first, followed by length
  420.      * of string, followed by characters in string, one per word.
  421.      */
  422.  
  423.     Tuple litmap;
  424.     int     i, n;
  425.     char   *str;
  426.     int     value, nstr;
  427.  
  428.     /*    enum_map := {[value, enum_lit]:
  429.      *    [enum_lit, value] in OVERLOADS(type_name)};
  430.      *    loop for value in [lbd..ubd] do
  431.      *    template with:= #(enum_lit := enum_map(value));
  432.      *    template    +:= [ abs(charac): charac in enum_lit ];
  433.      *    end loop for;
  434.      */
  435.     litmap = (Tuple) literal_map(type_name);
  436.     n = tup_size(litmap);
  437.     for (value = lbd; value <= ubd; value++) {
  438.         /* find string for value */
  439.         str = (char *) 0;
  440.         for (i = 1; i <= n; i += 2) {
  441.             if ((int) litmap[i + 1] == value) {
  442.                 str = litmap[i];
  443.                 break;
  444.             }
  445.         }
  446.         if (str == (char *) 0) {
  447.             chaos("type.c: init_enum cannot find literal value");
  448.         }
  449.         nstr = strlen(str);
  450.         /* put string length */
  451.         segment_put_int(stemplate, nstr);
  452.         for (i = 0; i < nstr; i++) {
  453.             segment_put_int(stemplate, (int) str[i]);
  454.         }
  455.     }
  456. }
  457.  
  458. /* Subtype elaboration */
  459.  
  460. void gen_subtype(Symbol type_name)                            /*;gen_subtype*/
  461. {
  462.     /* This procedure processes subtypes only.
  463.      * Note: all access subtypes have been changed to derived types by expander.
  464.      */
  465.  
  466.     int type_install_done;
  467.     int global_flag, i, nelts;
  468.     Node l_node, u_node, d_node, s_node, parent_l_node, parent_u_node;
  469.     Tuple type_list, index_list, discr_list, constraint, tup, sig;
  470.     int nb_dim, l, inum2, inum5, iden2, iden5;
  471.     long nb_elements, nb_len; /* long to avoid overflow problems */
  472.     Symbol type_mark, comp_type, index, typ, indx_type, b_index;
  473.     Symbol temp_name, field_name, temp_var, sym , x;
  474.     Fortup ft1;
  475.     Node low, high, b_low, b_high, dgt_node, lbd_node;
  476.     Node ubd_node, dlt_node, sml_node;
  477.     int static_qual, static_check;
  478.     Tuple base_index_list, field_map;
  479.     Const plow, phigh, lw_val, hg_val, b_lw_val, b_hg_val, consT;
  480.     int lw_vali, hg_vali, b_lw_vali, b_hg_vali;
  481.     int low_int, high_int, val_low = 0, val_high = 0, val_defined = 0;
  482.     float low_float, high_float;
  483.     Const low_const, high_const, small_const;
  484.     Rational rat;
  485.     int *num1, *den1, *num2, *den2;
  486.     Const parent_low_const, parent_high_const;
  487.     Segment stemplate;
  488.     struct tt_array *tt_array_ptr;
  489.     struct tt_s_array  *tt_s_array_ptr;
  490.     struct tt_e_range  *tt_e_range_ptr;
  491.     struct tt_i_range  *tt_i_range_ptr;
  492.     struct tt_fl_range *tt_fl_range_ptr;
  493.     struct tt_fx_range *tt_fx_range_ptr;
  494.     struct tt_c_record *tt_c_record_ptr;
  495.  
  496.  
  497.  
  498. #ifdef TRACE
  499.     if (debug_flag)
  500.         gen_trace_symbol("GEN_SUBTYPE", type_name);
  501. #endif
  502.  
  503.     type_mark = TYPE_OF(type_name);
  504.     constraint = get_constraint(type_name);
  505.  
  506.     switch((int) constraint[1]) {
  507.  
  508.     case(co_access):
  509.         if ((int) CONTAINS_TASK((Symbol) designated_type(type_name))) {
  510.             assign_same_reference(type_name, type_mark);
  511.             TYPE_KIND(type_name) = TYPE_KIND(type_mark);
  512.             TYPE_SIZE(type_name) = TYPE_SIZE(type_mark);
  513.         }
  514.         else {
  515.             assign_same_reference(type_name, symbol_daccess);
  516.             TYPE_KIND(type_name) = TYPE_KIND(symbol_daccess);
  517.             TYPE_SIZE(type_name) = TYPE_SIZE(symbol_daccess);
  518.         }
  519.         break;
  520.  
  521.     case(co_index):
  522.         sig = SIGNATURE(type_name);
  523.         index_list = (Tuple) sig[1];
  524.         comp_type = (Symbol) sig[2];
  525.         nb_dim = tup_size(index_list);
  526.         nb_elements = 1;
  527.         FORTUP(index = (Symbol), index_list, ft1);
  528.             l = length_of(index);
  529.             if (l >= 0)
  530.                 nb_elements *= l;
  531.             else
  532.                 nb_elements = -1;
  533.         ENDFORTUP(ft1);
  534.         if (nb_elements >= 0 && has_static_size(comp_type)) {
  535.             /* This is a kludge, needed for c43206a (shields 7-8-86) */
  536.             nb_len =  nb_elements * TYPE_SIZE(comp_type);
  537.             if (nb_len > MAX_STATIC_SIZE)
  538.                 nb_len = -1;
  539.             TYPE_SIZE(type_name) = nb_len;
  540.         }
  541.         else {
  542.             TYPE_SIZE(type_name) = -1;/* SETL uses -1 here */
  543.         }
  544.         stemplate = template_new(TT_C_ARRAY, size_of(type_name),
  545.           WORDS_ARRAY, TT_PTR(&tt_array_ptr));
  546.         tt_array_ptr->dim = nb_dim;
  547.         global_flag = has_static_size(type_name);
  548.         type_list = tup_copy(index_list);
  549.         type_list = tup_with(type_list, (char *) comp_type);
  550.         /* The first two items retrieved correspond to the component
  551.          * type and first index type, respectively. These are stored
  552.          * in the fixed part of the template; further items (if any)
  553.          * follow this fixed part.
  554.          */
  555.         nelts = 0;
  556.         while (tup_size(type_list)) {
  557.             typ = (Symbol) tup_frome(type_list);
  558.             reference_of(typ);
  559.             global_flag &= is_global(typ);
  560.             if (nelts == 0) { /* if component type */
  561.                 tt_array_ptr->component_base = REFERENCE_SEGMENT;
  562.                 tt_array_ptr->component_offset = REFERENCE_OFFSET;
  563.                 nelts++;
  564.             }
  565.             else if (nelts == 1)  { /* if first index type */
  566.                 tt_array_ptr->index1_base = REFERENCE_SEGMENT;
  567.                 tt_array_ptr->index1_offset = REFERENCE_OFFSET;
  568.                 nelts++;
  569.             }
  570.             else {
  571.                 segment_put_int(stemplate, REFERENCE_SEGMENT);
  572.                 segment_put_int(stemplate, (int) REFERENCE_OFFSET);
  573.             }
  574.         }
  575.         tup_free(type_list);
  576.         if ((nb_dim == 1) && global_flag) {
  577.             indx_type = (Symbol) index_list[1];
  578.             tup = SIGNATURE(indx_type);
  579.             low = (Node) tup[2];
  580.             high = (Node) tup[3];
  581.             stemplate = template_new(TT_S_ARRAY, size_of(type_name),
  582.               WORDS_S_ARRAY, TT_PTR(&tt_s_array_ptr));
  583.             tt_s_array_ptr->component_size = size_of(comp_type);
  584.             tt_s_array_ptr->index_size = size_of(indx_type);
  585.  
  586.             /* TBSL: check bounds are integers, assume so for now */
  587.             low_const = get_ivalue(low);
  588.             if (low_const->const_kind == CONST_INT)
  589.                 low_int = low_const->const_value.const_int;
  590.             else
  591.                 chaos("low bound not int");
  592.             high_const = get_ivalue(high);
  593.             if (high_const->const_kind == CONST_INT)
  594.                 high_int = high_const->const_value.const_int;
  595.             else
  596.                 chaos("high bound not int");
  597.             tt_s_array_ptr->salow = low_int;
  598.             tt_s_array_ptr->sahigh = high_int;
  599.         }
  600.  
  601.         static_qual = TRUE;
  602.         base_index_list = INDEX_TYPES(base_type(type_name));
  603.         base_index_list = tup_copy(base_index_list);
  604.         FORTUP(index = (Symbol), index_list, ft1);
  605.             b_index = (Symbol) tup_fromb(base_index_list);
  606.             tup = SIGNATURE(index);
  607.             low = (Node) tup[2];
  608.             high = (Node) tup[3];
  609.             tup = SIGNATURE(b_index);
  610.             b_low = (Node) tup[2];
  611.             b_high = (Node) tup[3];
  612.             lw_val = get_ivalue(low);
  613.             hg_val = get_ivalue(high);
  614.             b_lw_val = get_ivalue(b_low);
  615.             b_hg_val = get_ivalue(b_high);
  616.             if ( lw_val->const_kind == CONST_OM
  617.               || hg_val->const_kind == CONST_OM
  618.               || b_lw_val->const_kind == CONST_OM
  619.               || b_hg_val->const_kind == CONST_OM) {
  620.                 static_qual = FALSE;
  621.                 break;
  622.             }
  623.             /* TBSL:check that values are in fact integers */
  624.             else {
  625.                 lw_vali = lw_val->const_value.const_int;
  626.                 hg_vali = hg_val->const_value.const_int;
  627.                 b_lw_vali = b_lw_val->const_value.const_int;
  628.                 b_hg_vali = b_hg_val->const_value.const_int;
  629.                 if (lw_vali <= hg_vali &&/* No check on null ranges */
  630.                     (lw_vali < b_lw_vali || hg_vali > b_hg_vali)) {
  631.                     /* Raise CONSTRAINT_ERROR */
  632.                     gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  633.                     gen(I_RAISE);
  634.                     break;
  635.                 }
  636.             }
  637.         ENDFORTUP(ft1);
  638.  
  639.         install_type(type_name, stemplate, global_flag);
  640.  
  641.         if (!static_qual) {
  642.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  643.             gen_s(I_QUAL_SUB, base_type(type_name));
  644.             gen_ks(I_DISCARD_ADDR, 1, type_name);
  645.         }
  646.         break;
  647.  
  648.     case(co_range):
  649.         /* The SETL version builds range part of template and then puts it 
  650.          * in the proper place in the final template. In C we set the 
  651.          * desired values in val_low and val_high.
  652.          */
  653.         val_defined = FALSE;
  654.         l_node = (Node) constraint[2];
  655.         u_node = (Node) constraint[3];
  656.         tup = SIGNATURE(type_mark);
  657.         parent_l_node = (Node) tup[2];
  658.         parent_u_node = (Node) tup[3];
  659.         parent_low_const = get_ivalue(parent_l_node);
  660.         parent_high_const = get_ivalue(parent_u_node);
  661.         low_const = get_ivalue(l_node);
  662.         high_const = get_ivalue(u_node);
  663.         if (low_const->const_kind != CONST_OM
  664.           && high_const->const_kind != CONST_OM
  665.           && parent_low_const->const_kind != CONST_OM
  666.           && parent_high_const->const_kind != CONST_OM) {
  667.             /* static range */
  668.             static_check = TRUE;
  669.             global_flag = TRUE;
  670.  
  671.             if ( const_gt(low_const, high_const)/* null range */
  672.               ||(const_ge(low_const, parent_low_const)
  673.               && const_le(high_const, parent_high_const))) {
  674.  
  675.                 /* template    := [val_low, val_high]; */
  676.                 val_defined = TRUE;
  677.                 val_low = get_const_int(low_const);
  678.                 val_high =  get_const_int(high_const);
  679.             }
  680.             else {
  681.                 gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  682.                 gen(I_RAISE);
  683.                 /* template    := [val_low, val_high]; */
  684.                 val_defined = TRUE;
  685.                 val_low = get_const_int(low_const);
  686.                 val_high =  get_const_int(high_const);
  687.             }
  688.         }
  689.         else {
  690.             gen_value(l_node);
  691.             gen_value(u_node);
  692.             if (base_type(type_mark) == type_mark) {
  693.                 /* Subtype of the base type, no check needed */
  694.                 static_check = TRUE;
  695.             }
  696.             else {
  697.                 static_check = FALSE;
  698.             }
  699.             global_flag = FALSE;
  700.             /* TBSL: see if int_const is proper for all types if parent_ not
  701.              * defined    ds 8-1-85
  702.              */
  703.             /* template     := [parent_low ? 0, parent_high ? 0]; */
  704.             if (parent_low_const->const_kind != CONST_OM) {
  705.                 val_defined = TRUE;
  706.                 val_low =  get_const_int(parent_low_const);
  707.             }
  708.             else {
  709.                 val_defined = TRUE;
  710.                 val_low = 0;
  711.             }
  712.             if (parent_high_const->const_kind != CONST_OM) {
  713.                 val_defined = TRUE;
  714.                 val_high = get_const_int(parent_high_const);
  715.             }
  716.             else {
  717.                 val_defined = TRUE;
  718.                 val_high = 0;
  719.             }
  720.         }
  721.  
  722.         TYPE_KIND(type_name) = TYPE_KIND(type_mark);
  723.         TYPE_SIZE(type_name) = TYPE_SIZE(type_mark);
  724.         if (is_enumeration_type(type_name)) {
  725.             /* SETL code builds trailing part then puts standard header at front
  726.              * In C, we have set val_defined if there are values to insert
  727.              * and have the values in val_low and val_high, respectively.
  728.              */
  729.             /* template :=  [TT_E_RANGE, size_of(type_mark)] + template */
  730.             stemplate = template_new(TT_E_RANGE, size_of(type_mark),
  731.               WORDS_E_RANGE, TT_PTR(&tt_e_range_ptr));
  732.             if (val_defined) {
  733.                 tt_e_range_ptr->elow = val_low;
  734.                 tt_e_range_ptr->ehigh = val_high;
  735.             }
  736.             reference_of(root_type(type_mark));
  737.             tt_e_range_ptr->ebase = REFERENCE_SEGMENT;
  738.             tt_e_range_ptr->eoff = REFERENCE_OFFSET;
  739.         }
  740.         else {
  741.             /* TBSL: need re adjust type to i_range_l if long, etc */
  742.             /* template := [TT_I_RANGE, size_of(type_mark)]+template; */
  743.             stemplate = template_new(TT_I_RANGE, size_of(type_mark),
  744.               WORDS_I_RANGE, TT_PTR(&tt_i_range_ptr));
  745.             tt_i_range_ptr->ilow = val_low;
  746.             tt_i_range_ptr->ihigh = val_high;
  747.         }
  748.         /* This is more or less equivalent to INSTALL_TYPE: */
  749.         if (global_flag) {    /* static type */
  750.             assign_same_reference(type_name, get_constant_name(stemplate));
  751.         }
  752.         else {
  753.             if (CURRENT_LEVEL == 1) {/* non-static, global */
  754.                 next_global_reference_template(type_name, stemplate);
  755.                 gen_s(I_TYPE_GLOBAL, type_name);
  756.             }
  757.             else {
  758.                 next_local_reference(type_name);
  759.                 temp_name = new_unique_name("type_template");
  760.                 assign_same_reference(temp_name, get_constant_name(stemplate));
  761.                 gen_s(I_TYPE_LOCAL, temp_name);
  762.                 gen_s(I_UPDATE_AND_DISCARD, type_name);
  763.             }
  764.         }
  765.  
  766.         if (!static_check) {
  767.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  768.             gen_s(I_QUAL_SUB, type_mark);
  769.             gen_ks(I_DISCARD_ADDR, 1, type_name);
  770.         }
  771.         break;
  772.  
  773.     case(co_digits):
  774.         l_node = (Node) constraint[2];
  775.         u_node = (Node) constraint[3];
  776.         d_node = (Node) constraint[4];
  777.         tup = get_constraint(TYPE_OF(type_name));
  778.         lbd_node = (Node) tup[2];
  779.         ubd_node = (Node) tup[3];
  780.         dgt_node = (Node) tup[4];
  781.         if (const_gt(get_ivalue(d_node), get_ivalue(dgt_node))) {
  782.             gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  783.             gen(I_RAISE);
  784.         }
  785.         low_const = get_ivalue(l_node);
  786.         high_const = get_ivalue(u_node);
  787.         if (low_const->const_kind != CONST_OM
  788.           && high_const->const_kind != CONST_OM) {
  789.             plow = get_ivalue(lbd_node);
  790.             phigh = get_ivalue(ubd_node);
  791.             if (plow->const_kind != CONST_OM && phigh->const_kind != CONST_OM) {
  792.                 if (const_lt(low_const, high_const)
  793.                   && (const_lt(low_const, plow) || const_gt(high_const,phigh))){
  794.                     gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  795.                     gen(I_RAISE);
  796.                 }
  797.             }
  798.             global_flag = TRUE;
  799.             /* template    := [low, high]; */
  800.             low_float = REALV(low_const);
  801.             high_float = REALV(high_const);
  802.         }
  803.         else {
  804.             gen_value(l_node);
  805.             gen_value(u_node);
  806.             global_flag = FALSE;
  807.             low_float = 0.0;
  808.             high_float = 0.0;
  809.             /* template    := [0, 0]; */
  810.         }
  811.         TYPE_KIND(type_name) = TYPE_KIND(type_mark);
  812.         TYPE_SIZE(type_name) = TYPE_SIZE(type_mark);
  813.         /* template := [TT_F_RANGE, size_of(type_mark)] + template; */
  814. #ifdef TBSL
  815.         -review carefully the setting of template here
  816. #endif
  817.         stemplate = template_new(TT_FL_RANGE, size_of(type_mark),
  818.           WORDS_FL_RANGE, TT_PTR(&tt_fl_range_ptr));
  819.         tt_fl_range_ptr->fllow = low_float;
  820.         tt_fl_range_ptr->flhigh = high_float;
  821.         install_type(type_name, stemplate, global_flag);
  822.         break;
  823.  
  824.     case(co_delta):
  825. #ifdef TBSL
  826.         -- review template initialization. Note that low and high as et
  827.             -- in template must be longs.
  828. #endif
  829.         l_node = (Node) constraint[2];
  830.         u_node = (Node) constraint[3];
  831.         d_node = (Node) constraint[4];
  832.         s_node = (Node) constraint[5];
  833.         constraint = get_constraint(TYPE_OF(type_name));
  834.         lbd_node = (Node) constraint[2];
  835.         ubd_node = (Node) constraint[3];
  836.         dlt_node = (Node) constraint[4];
  837.         sml_node = (Node) constraint[5];
  838.         consT = get_ivalue(d_node);
  839.         if (consT->const_kind != CONST_RAT)
  840.             chaos("arg not rational");
  841.         rat = consT->const_value.const_rat;
  842.         num1 = num(rat);
  843.         den1 = den(rat);
  844.         consT = get_ivalue(dlt_node);
  845.         /* [num2, den2] := get_ivalue(dlt_node); */
  846.         if (consT->const_kind != CONST_RAT)
  847.             chaos("arg not rational");
  848.         rat = consT->const_value.const_rat;
  849.         num2 = num(rat);
  850.         den2 = den(rat);
  851.         if (int_lss(int_mul(num1, den2), int_mul(num2, den1))) {
  852.             gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  853.             gen(I_RAISE);
  854.         }
  855.         /* The subtype uses the same run-time representation as the type
  856.          * so we place in the template the 'small of the type.
  857.          */
  858.         small_const = get_ivalue(sml_node);
  859.         split_powers(num(RATV(small_const)));
  860.         inum2 = split_powers_2;
  861.         inum5 = split_powers_5;
  862.         split_powers(den(RATV(small_const)));
  863.         iden2 = split_powers_2;
  864.         iden5 = split_powers_5;
  865.         /* template := [TT_FIXED, size_of(type_mark), num2-den2, num5-den5]; */
  866.         stemplate = template_new(TT_FX_RANGE, size_of(type_mark),
  867.           WORDS_FX_RANGE, TT_PTR(&tt_fx_range_ptr));
  868.         tt_fx_range_ptr->small_exp_2 = inum2 - iden2;
  869.         tt_fx_range_ptr->small_exp_5 = inum5 - iden5;
  870.         /* TBSL: may want to force size to 4 here */
  871.         root_type(type_name) = root_type(base_type(type_name));
  872.         low_const = get_ivalue(l_node);
  873.         high_const = get_ivalue(u_node);
  874.         if (low_const->const_kind != CONST_OM
  875.           && high_const->const_kind != CONST_OM) {
  876.             plow = get_ivalue(lbd_node);
  877.             phigh = get_ivalue(ubd_node);
  878.             if (plow->const_kind != CONST_OM && phigh->const_kind != CONST_OM) {
  879.                 if (int_lss(int_mul(num(RATV(low_const)),den(RATV(high_const))),
  880.                   int_mul(num(RATV(high_const)), den(RATV(low_const))))
  881.                   && (int_lss(int_mul(num(RATV(low_const)), den(RATV(plow))),
  882.                   int_mul(num(RATV(plow)), den(RATV(low_const))))
  883.                   || int_gtr(int_mul(num(RATV(high_const)), den(RATV(phigh))),
  884.                   int_mul(num(RATV(phigh)), den(RATV(high_const)))))) {
  885.                     gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  886.                     gen(I_RAISE);
  887.                 }
  888.             }
  889.             global_flag = TRUE;
  890.  
  891.             tt_fx_range_ptr->fxlow = rat_tof(low_const, small_const, 1);
  892.             tt_fx_range_ptr->fxhigh = rat_tof(high_const, small_const, 1);
  893.  
  894.             TYPE_KIND(type_name) = TK_LONG;
  895.             TYPE_SIZE(type_name) = su_size(TK_LONG);
  896.         }
  897.         else {
  898.             global_flag = FALSE;
  899.             segment_put_int(stemplate, 0);
  900.             segment_put_int(stemplate, 0);
  901.             /* template   +:= if template(1+TT_OBJECT_SIZE) = 1 then [0, 0] *
  902.                   else [0, 0, 0, 0] *    end; */
  903.             gen_value(l_node);
  904.             gen_s(I_QUAL_RANGE, type_mark);
  905.             gen_value(u_node);
  906.             gen_s(I_QUAL_RANGE, type_mark);
  907.         }
  908.  
  909.         install_type(type_name, stemplate, global_flag);
  910.         break;
  911.  
  912.     case(co_discr):
  913.         type_install_done = FALSE;
  914.         type_mark = base_type(type_mark);
  915.         field_map = (Tuple) constraint[2];
  916.         stemplate = template_new(TT_C_RECORD, size_of(type_mark),
  917.           WORDS_C_RECORD, TT_PTR(&tt_c_record_ptr));
  918.         reference_of(type_mark);
  919.         tt_c_record_ptr->cbase = REFERENCE_SEGMENT;
  920.         tt_c_record_ptr->coff = REFERENCE_OFFSET;
  921.         /* TBSL: Adjust type_size if no default values for discriminants */
  922.         TYPE_KIND(type_name) = TT_C_RECORD;
  923.         TYPE_SIZE(type_name) = TYPE_SIZE(type_mark);
  924.  
  925.         /* obtain discriminants in same order as in unconstrained type */
  926.         tup = SIGNATURE(type_mark);
  927.         /* need tup_copy for discr_list since used in tup_frome below */
  928.         discr_list = tup_copy((Tuple) tup[3]);
  929.         tt_c_record_ptr->nb_discr_c = tup_size(discr_list);
  930.         if (tup_size(field_map) == 0) {
  931.             /* Special case: vals of discriminants fetched from record object */
  932.             /* already on TOS. */
  933.             global_flag = FALSE;
  934.             for (i = 1; i <= tup_size(discr_list); i++) {
  935.                 segment_put_int(stemplate, 0);
  936.             }
  937.             /* template   +:= [0: x in discr_list]; */
  938.             temp_var = new_unique_name("temporary");
  939.  
  940.             next_local_reference(temp_var);
  941.             gen_s(I_UPDATE, temp_var);
  942.             while (tup_size(discr_list) != 0) {
  943.                 field_name = (Symbol) tup_frome(discr_list);
  944.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, temp_var);
  945.                 /* SETL has field_name as last argument, presumably as part of
  946.                  * comment part of instruction and not part of generated code
  947.                  * ds 7-5-85
  948.                  */
  949.                 /* gen_ki(I_ADD_IMMEDIATE, mu_word, *
  950.                     * field_offset(field_name)(TARGET), field_name);
  951.                  */
  952.                 gen_ki(I_ADD_IMMEDIATE, mu_word, FIELD_OFFSET(field_name));
  953.                 gen_k(I_DEREF, kind_of(TYPE_OF(field_name)));
  954.             }
  955.         }
  956.         else {
  957.             /* global_flag = is_global(type_mark) and
  958.              *  (forall x in
  959.              * discr_list | is_ivalue(field_map(x))); 
  960.              */
  961.             global_flag = is_global(type_mark) && (TYPE_SIZE(type_mark) != -1);
  962.             FORTUP(x = (Symbol), discr_list, ft1);
  963.                 if (!is_ivalue(discr_map_get(field_map, x))) {
  964.                     global_flag = FALSE;
  965.                     break;
  966.                 }
  967.             ENDFORTUP(ft1);
  968.             if (global_flag) {
  969.                 /* template +:= [get_ivalue(field_map(x)):x in discr_list]; */
  970.                 FORTUP(sym = (Symbol), discr_list, ft1);
  971.                     segment_put_const(stemplate,
  972.                       get_ivalue(discr_map_get(field_map, sym)));
  973.                 ENDFORTUP(ft1);
  974.             }
  975.             else {
  976.                 /* template +:= [0: x in discr_list]; */
  977.                 for (i = 1; i <= tup_size(discr_list); i++) {
  978.                     segment_put_int(stemplate, 0);
  979.                 }
  980.                 /* if there is a TT_D_ARRAY or a TT_D_RECORD containing
  981.                  * a TT_D_ARRAY, a check is made so that the discriminant
  982.                  * belongs to the index subtype of the array.
  983.                  */
  984.                 while (tup_size(discr_list) != 0) {
  985.                     field_name = (Symbol) tup_frome(discr_list);
  986.                     d_node = (discr_map_get(field_map, field_name));
  987.                     gen_value(d_node);
  988.                     gen_s (I_QUAL_RANGE, TYPE_OF (field_name));
  989.                 }
  990.                 install_type(type_name, stemplate, global_flag);
  991.  
  992.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  993.                 gen (I_CHECK_REC_SUBTYPE);
  994.                 type_install_done = TRUE;
  995.  
  996.             }
  997.         }
  998.         if (! type_install_done) {
  999.             install_type(type_name, stemplate, global_flag);
  1000.         }
  1001.         break;
  1002.     default:
  1003.  
  1004.         compiler_error_c("Unexpected subtype constraint: ", constraint);
  1005.     }
  1006. }
  1007.  
  1008. static void install_type(Symbol type_name, Segment stemplate, int global_flag)
  1009.                                                             /*;install_type*/
  1010. {
  1011.     Symbol temp_name;
  1012.  
  1013.     if (global_flag) {        /* static type */
  1014.         assign_same_reference(type_name, get_constant_name(stemplate));
  1015.     }
  1016.     else if (CURRENT_LEVEL == 1) {/* non-static, global */
  1017.         next_global_reference_template(type_name, stemplate);
  1018.         gen_s(I_TYPE_GLOBAL, type_name);
  1019.     }
  1020.     else {            /* non-static, local */
  1021.         next_local_reference(type_name);
  1022.         temp_name = new_unique_name("type_template");
  1023.         assign_same_reference(temp_name, get_constant_name(stemplate));
  1024.         gen_s(I_TYPE_LOCAL, temp_name);
  1025.         gen_s(I_UPDATE_AND_DISCARD, type_name);
  1026.     }
  1027.     /* free template - this is final use*/
  1028.     segment_free(stemplate);
  1029. }
  1030.  
  1031. static Segment make_fixed_template(Const old_lbd, Const old_ubd,
  1032.   Const old_delta, Const old_small_arg, struct tt_fx_range **ptr)
  1033.                                                     /*;make_fixed_template*/
  1034. {
  1035.     /*DESCR: Elaborates the template from the front end's fixed point ITYPE.
  1036.      *INPUT: old_itype: Fixed Point ITYPE from ADASEM.(with added
  1037.      *               small field for the new length clause.  This
  1038.      *           field will be OM unless small has been set by
  1039.      *           length clause.
  1040.      *OUTPUT: Returns template: Fixed point type template.
  1041.      */
  1042.  
  1043.     int small_exp_2,    /* parameters of new type template */
  1044.       small_exp_5, size;
  1045.     int bits;
  1046.     int power_conv; /* set when cannot convert small representation */
  1047.     long new_lbd, new_ubd;
  1048.     int num_2, num_5, num_other, /* powers of numerator */
  1049.       den_2, den_5, den_other;/* powers of denominator */
  1050.     Segment stemplate;
  1051.     Const old_small;        /* need to copy arg since value changed */
  1052.     struct tt_fx_range *tt_fx_range_ptr;
  1053.  
  1054.     old_small = rat_const(RATV(old_small_arg));
  1055.  
  1056.     /* find SMALL exponents */
  1057.     split_powers(num(RATV(old_small)));
  1058.     num_2 = split_powers_2;
  1059.     num_5 = split_powers_5;
  1060.     num_other = split_powers_value;
  1061.     /* [den_2, den_5, den_other] := split_powers(den(old_small)); */
  1062.     split_powers(den(RATV(old_small)));
  1063.     den_2 = split_powers_2;
  1064.     den_5 = split_powers_5;
  1065.     den_other = split_powers_value;
  1066.     if (num_other != den_other) {/* small not allowed */
  1067.         user_error("Small not supported by implementation.(Appendix F)");
  1068.         power_conv = power_of_2(old_delta);
  1069.         if (power_conv) {
  1070.             user_error(
  1071.               "Precision not supported by implementation. (Appendix F)");
  1072.         }
  1073.         small_exp_2 = power_of_2_power;
  1074.         small_exp_5 = 0;
  1075.         RATV(old_small) = power_of_2_small;
  1076.     }
  1077.     else {
  1078.         small_exp_2 = num_2 - den_2;
  1079.         small_exp_5 = num_5 - den_5;
  1080.     }
  1081. #ifdef TBSL
  1082.     if (ABS(small_exp_2) > 30 || ABS(small_exp_5) > 9) {
  1083.         -- check that 1/MAX_INT < old_small < MAX_INT 
  1084.             SIGN(small_exp_2) == SIGN(small_exp_5) && 
  1085.             5**(iabs( small_exp_5)) * 2**(iabs( small_exp_2)) > MAX_INT ) {
  1086.             user_error(PRECISION_NOT_SUPPORTED);
  1087.         }
  1088. #endif
  1089.     bits = fx_mantissa(RATV(old_lbd), RATV(old_ubd), RATV(old_small))+1;
  1090.     /* +1 for sign*/
  1091.     if (bits > WORD_SIZE) {
  1092.         user_error(PRECISION_NOT_SUPPORTED);
  1093.     }
  1094.     size = su_size(TK_LONG);    /* FORCE this for initial C version  ds 6-6-85
  1095.                         */
  1096.     new_lbd = rat_tof(old_lbd, old_small, size);
  1097.     new_ubd = rat_tof(old_ubd, old_small, size);
  1098.     /* return [TT_FIXED, size, small_exp_2, small_exp_5]+new_lbd+new_ubd; */
  1099.     stemplate = template_new(TT_FX_RANGE, size, WORDS_FX_RANGE,
  1100.       TT_PTR(&tt_fx_range_ptr));
  1101.     tt_fx_range_ptr->small_exp_2 = small_exp_2;
  1102.     tt_fx_range_ptr->small_exp_5 = small_exp_5;
  1103.     tt_fx_range_ptr->fxlow = new_lbd;
  1104.     tt_fx_range_ptr->fxhigh = new_ubd;
  1105.     *ptr = tt_fx_range_ptr;
  1106.     return (stemplate);
  1107. }
  1108.  
  1109. static void split_powers(int *avalue)                        /*;split_powers*/
  1110. {
  1111.     /*DESCR: This procedure splits value into a power of 5, a power of 2
  1112.      *       and the remaining factors.
  1113.      *INPUT: value: integer.
  1114.      *OUTPUT: [pow_2 pow_5 others] such that
  1115.      *        value= 2**pow_2 * 5**pow_5 * others
  1116.      */
  1117.     /* The C version does not return a tuple, but sets the variables
  1118.      * split_powers_2, split_powers_5 and split_powers_value global
  1119.      * to this module
  1120.      */
  1121.  
  1122.     int     pow_2,        /* desired power of 2 */
  1123.     pow_5;        /* desired power of 5 */
  1124.     int     *int_2, *int_5;
  1125.     int     *v;
  1126.  
  1127.     pow_2 = 0;
  1128.     pow_5 = 0;
  1129.     int_2 = int_fri(2);    /* should be global   */
  1130.     int_5 = int_fri(5);
  1131.     v     = int_copy(avalue);
  1132.  
  1133.     while((v[v[0]] % 2 ) == 0 && v[0] > 0) {
  1134.         v = int_quo(v, int_2);
  1135.         pow_2 += 1;
  1136.     }
  1137.     while((v[v[0]] % 5 ) == 0 && v[0] > 0) {
  1138.         v = int_quo(v, int_5);
  1139.         pow_5 += 1;
  1140.     }
  1141.     /* return [pow_2, pow_5, value]; */
  1142.     split_powers_2 = pow_2;
  1143.     split_powers_5 = pow_5;
  1144.     split_powers_value = int_toi(v);
  1145. }
  1146.  
  1147. long rat_tof(Const value, Const small, int size)                /*;rat_tof*/
  1148. {
  1149.     /* DESCR: This procedure converts a rational number into a fixed
  1150.      *     point number with the given small and size.
  1151.      * INPUT: value: [num den], A rational number(see RATIONAL
  1152.      *            ARITHMETIC PACKAGE).
  1153.      *     small: the given small as a rational number
  1154.      *     size:  1 or 2, size(in words or tuples) for the result
  1155.      * OUTPUT: [N] N being one or two integers(depending on size)
  1156.      */
  1157.  
  1158.     long    N;            /* intermediate value */
  1159.  
  1160.     /* for first C version, use rat_tol which returns long. SETL uses rat_toi.*/
  1161.     /* force size to be 1 for initial C version */
  1162.     size = 1;
  1163.     if (value->const_kind != CONST_RAT || small->const_kind != CONST_RAT) {
  1164. #ifdef DEBUG
  1165.         zpcon(value); 
  1166.         zpcon(small);
  1167. #endif
  1168.         chaos("rat_tof arguments not rationals");
  1169.     }
  1170.     N = rat_tol(rat_div(RATV(value), RATV(small)));
  1171.     if (size == 1) {
  1172. #ifdef TBSN
  1173. -- ignore overflow: 
  1174.         if called by make_fixed_template message already
  1175.         -- emitted. In case of expression or initial value should be OK
  1176.             -- (as long as they belong to the type)
  1177.             if (arith_overflow) {
  1178.             compiler_error("Value too big");
  1179.         }
  1180. #endif
  1181.         return N;
  1182.     }
  1183. #ifdef TBSN
  1184.     -- do this when have multiple fixed types
  1185.         $will work anyway...
  1186.     else
  1187.     if N >= 0 then
  1188.     if N > MAX_INT*(MAX_UNS+1)+MAX_UNS then
  1189.     compiler_error("Value too big");
  1190.     end if;
  1191.     RAT_TO_F_1 = N div (MAX_UNS+1);
  1192.     RAT_TO_F_2 = N mod (MAX_UNS+1);
  1193.     return;
  1194.     else
  1195.     if N < MIN_INT*(MAX_UNS+1) then
  1196.     compiler_error("Value too big");
  1197.     end if;
  1198.     RAT_TOF_1 = (N-MAX_UNS) div (MAX_UNS+1);
  1199.     RAT_TOF_2 = N mod (MAX_UNS+1);
  1200.     return;
  1201.     end if;
  1202.     end if;
  1203. #endif
  1204. }
  1205.  
  1206. static void process_record(Symbol type_name)                /*;process_record*/
  1207. {
  1208.     Tuple repr_tup, tup, type_list, discr_decl, fixed_part, dep_types;
  1209.     Node invariant_node, variant_node, node, id_list_node, n, d;
  1210.     Node subtype_node, id_node, type_node;
  1211.     Fortup ft1, ft2;
  1212.     int     i, varying_size_flag, type_class, discr_with_defaults;
  1213.     Symbol subtype_name, t_name, discr, some_discr_name;
  1214.     Tuple discr_subtypes;
  1215.     Segment stemplate;
  1216.     struct tt_u_record *tt_u_record_ptr;
  1217.  
  1218. #ifdef TRACE
  1219.     if (debug_flag )
  1220.         gen_trace_symbol("PROCESS_RECORD", type_name);
  1221. #endif
  1222.  
  1223.     segment_empty(VARIANT_TABLE);
  1224.     CURRENT_FIELD_NUMBER = 0;
  1225.     CURRENT_FIELD_OFFSET = 0;
  1226.     segment_empty(FIELD_TABLE);
  1227.     INTERNAL_ACCESSED_TYPES = tup_new(0);
  1228.     STATIC_REC = TRUE;        /* just an assumption... */
  1229.  
  1230.     tup = SIGNATURE(type_name);
  1231.     /* [[invariant_node, variant_node], discr_decl] := SIGNATURE(type_name); */
  1232.     /* recall that signature is 5-tuple in C version */
  1233.     invariant_node = (Node) tup[1];
  1234.     variant_node = (Node) tup[2];
  1235.     discr_decl = (Tuple) tup[3];
  1236.     type_list = tup_new(0);
  1237.     fixed_part = tup_new(0);
  1238.     FORTUP(node = (Node), N_LIST(invariant_node), ft1);
  1239.         switch(N_KIND(node)) {
  1240.         case(as_field):
  1241.             id_list_node = N_AST1(node);
  1242.             FORTUP(n = (Node), N_LIST(id_list_node), ft2);
  1243.                 fixed_part = tup_with(fixed_part, (char *) N_UNQ(n));
  1244.             ENDFORTUP(ft2);
  1245.             /* fixed_part    +:= [N_UNQ(n) : n in N_LIST(id_list_node)]; */
  1246.             break;
  1247.         case(as_subtype_decl):
  1248.             type_list = tup_with(type_list, (char *) node);
  1249.             break;
  1250.         case(as_deleted):
  1251.             break;
  1252.         default:
  1253.             compiler_error_k("Unexpected kind of selector in record: ",
  1254.               node);
  1255.         }
  1256.     ENDFORTUP(ft1);
  1257.  
  1258.     /* then, are there discriminants ? */
  1259.     if (tup_size(discr_decl) != 0) {
  1260.         linearize_record(discr_decl, OPT_NODE);
  1261.  
  1262.         /* discriminant dependent subtypes: elaborate and check if varying sz */
  1263.         /* dep_types         := [discr_dep_subtype(d):d in type_list]; */
  1264.         dep_types = tup_new(tup_size(type_list));
  1265.         FORTUPI(d = (Node), type_list, i, ft1);
  1266.             dep_types[i] = (char *) discr_dep_subtype(d);
  1267.         ENDFORTUP(ft1);
  1268.         varying_size_flag = FALSE;
  1269.         for (i = 1; i <= tup_size(type_list); i++) {
  1270.             subtype_node = (Node) type_list[i];
  1271.             id_node = N_AST1(subtype_node);
  1272.             subtype_name = N_UNQ(id_node);
  1273.  
  1274.             /* An anonymous subtype used by a constrained access subtype 
  1275.              * indication, that refers to discriminants, does not make the
  1276.              * record of variable size....
  1277.              */
  1278.             if (dep_types[i] && !tup_mem((char *) subtype_name,
  1279.               INTERNAL_ACCESSED_TYPES)) {
  1280.                 varying_size_flag = TRUE;
  1281.                 break;
  1282.             }
  1283.         }
  1284.  
  1285.         /* class of type: */
  1286.         some_discr_name = (Symbol) discr_decl[tup_size(discr_decl)];
  1287.         discr_with_defaults = (Node) default_expr(some_discr_name) != OPT_NODE;
  1288.         if (discr_with_defaults) {
  1289.             type_class = TT_U_RECORD;
  1290.             TYPE_KIND(type_name) = TT_U_RECORD;
  1291.             /* discr_subtypes := [ TYPE_OF(discr) : discr in discr_decl]; */
  1292.             discr_subtypes = tup_new(tup_size(discr_decl));
  1293.             FORTUPI(discr = (Symbol), discr_decl, i, ft1);
  1294.                 discr_subtypes[i] = (char *) TYPE_OF(discr);
  1295.             ENDFORTUP(ft1);
  1296.             /* loop forall i in [1..#type_list] | dep_types(i) do */
  1297.             for (i = 1; i <= tup_size(type_list); i++) {
  1298.                 if (dep_types[i]) {
  1299.                     id_node = N_AST1((Node) type_list[i]);
  1300.                     eval_max_size(N_UNQ(id_node), discr_subtypes);
  1301.                 }
  1302.             }
  1303.         }
  1304.         else if (varying_size_flag) {
  1305.             TYPE_KIND(type_name) = TT_V_RECORD;
  1306.             type_class = TT_V_RECORD;
  1307.         }
  1308.         else {
  1309.             TYPE_KIND(type_name) = TT_U_RECORD;
  1310.             type_class = TT_U_RECORD;
  1311.         }
  1312.  
  1313.         stemplate = template_new(type_class, 0, WORDS_U_RECORD,
  1314.           TT_PTR(&tt_u_record_ptr));
  1315.         tt_u_record_ptr->nb_field_u = 0;    /* nb_fields */
  1316.         tt_u_record_ptr->nb_discr_u = tup_size(discr_decl);    /* nb_discr */
  1317.         tt_u_record_ptr->nb_fixed_u =
  1318.           tup_size(discr_decl) + tup_size(fixed_part);        /* nb_fixed */
  1319.         /* set first entry in field_table after end of fixed part of template */
  1320.  
  1321.         tt_u_record_ptr->first_case = linearize_record(fixed_part,variant_node);
  1322.         /* size of variant table */
  1323.         tt_u_record_ptr->variant = segment_get_maxpos(VARIANT_TABLE);
  1324.     }
  1325.     else {
  1326.         FORTUP(type_node = (Node), type_list, ft1);/* Elaborate types */
  1327.             id_node = N_AST1(type_node);
  1328.             t_name = N_UNQ(id_node);
  1329.             gen_subtype(t_name);
  1330.         ENDFORTUP(ft1);
  1331.         TYPE_KIND(type_name) = TT_RECORD;
  1332.         type_class = TT_RECORD;
  1333.         stemplate = template_new(TT_RECORD, 0, WORDS_RECORD, 
  1334.           TT_PTR(&tt_u_record_ptr));
  1335.         linearize_record(fixed_part, OPT_NODE);
  1336.     }
  1337.  
  1338.     if (type_class == TT_V_RECORD) {
  1339.         TYPE_SIZE(type_name) = -1;/* TBSL: SETL uses -1 here */
  1340.     }
  1341.     else {
  1342.         TYPE_SIZE(type_name) = CURRENT_FIELD_OFFSET;
  1343.     }
  1344.     tt_u_record_ptr->object_size = size_of(type_name);
  1345.     repr_tup = REPR(type_name);
  1346.     if (repr_tup != (Tuple)0) {
  1347.        tt_u_record_ptr->repr_size = (int) repr_tup[2];
  1348.     }
  1349.     else {
  1350.        tt_u_record_ptr->repr_size = 0;
  1351.     }
  1352.     /* template may also be tt_record case, but no harm since
  1353.      * nb_field_u at same offset as nb_field 
  1354.      */
  1355.     tt_u_record_ptr->nb_field_u = CURRENT_FIELD_NUMBER;
  1356.  
  1357.     /* template +:= FIELD_TABLE+VARIANT_TABLE; */
  1358.     segment_append(stemplate, FIELD_TABLE);
  1359.     segment_append(stemplate, VARIANT_TABLE);
  1360.     install_type(type_name, stemplate, STATIC_REC);
  1361. }
  1362.  
  1363. static int linearize_record(Tuple fixed_part_list, Node variant_part_node)
  1364.                                                         /*;linearize_record*/
  1365. {
  1366.     /* process fixed part
  1367.      * For each record comp in fixed part, add three entries to FIELD_TABLE:
  1368.      * offset, base of template for comp, segment of template for component.
  1369.      */
  1370.  
  1371.     Symbol f_name, f_type, name;
  1372.     Fortup ft1, ft2;
  1373.     int     tsize, first_field, v_index, index;
  1374.     Node variant_node, name_node, others_body, alt_node;
  1375.     Node f_node, v_node, id_list_node, node, n_sym;
  1376.     int     save_field_offset, max_field_offset, variant_offset;
  1377.     Tuple bodies, f_part, ntable, tup4, table, tup;
  1378.     Tuple case_range;
  1379.     int     i, n, b;
  1380.  
  1381. #ifdef TRACE
  1382.     if (debug_flag) {
  1383.         gen_trace_symbols("LINEARIZE_RECORD_F", fixed_part_list);
  1384.         gen_trace_node("LINEARIZE_RECORD_V", variant_part_node);
  1385.     }
  1386. #endif
  1387.     FORTUP(f_name = (Symbol), fixed_part_list, ft1);
  1388.         f_type = TYPE_OF(f_name);
  1389.         FIELD_NUMBER(f_name) = (char *) CURRENT_FIELD_NUMBER;
  1390.         CURRENT_FIELD_NUMBER += 1;
  1391.         FIELD_OFFSET(f_name) = CURRENT_FIELD_OFFSET;
  1392.         /* FIELD_TABLE +:= [CURRENT_FIELD_OFFSET] + * reference_of(f_type); */
  1393.         segment_put_word(FIELD_TABLE, CURRENT_FIELD_OFFSET);
  1394.         reference_of(f_type);
  1395.         segment_put_int(FIELD_TABLE, REFERENCE_SEGMENT);
  1396.         segment_put_int(FIELD_TABLE, REFERENCE_OFFSET);
  1397.         /* STATIC_REC  and:= is_static_type(f_type); */
  1398.         STATIC_REC = STATIC_REC ? is_static_type(f_type) : FALSE;
  1399.         if (CURRENT_FIELD_OFFSET != -1) {
  1400.             tsize = TYPE_SIZE(f_type);
  1401.             if (tsize >= 0 && CURRENT_FIELD_OFFSET >= 0) {
  1402.                 CURRENT_FIELD_OFFSET += tsize;
  1403.             }
  1404.             else {
  1405.                 CURRENT_FIELD_OFFSET = -1;
  1406.             }
  1407.         }
  1408.     ENDFORTUP(ft1);
  1409.  
  1410.     if (variant_part_node != OPT_NODE) {
  1411.         name_node = N_AST1(variant_part_node);
  1412.         variant_node = N_AST2(variant_part_node);
  1413.         name = N_UNQ(name_node);
  1414.         /*-- bodies is used in tup_from? below: see if tup_copy needed here
  1415.             *-    ds  6-25-85
  1416.             */
  1417.         tup = make_case_table(variant_node);
  1418.         table = (Tuple) tup[1];
  1419.         bodies = (Tuple) tup[2];
  1420.         bodies = tup_copy(bodies);/* to be safe - see above comment */
  1421.         others_body = (Node) tup[3];
  1422.         tup_free(tup);
  1423.         /* [table, bodies, others_body] := make_case_table(variant_node); */
  1424.         n = tup_size(table);
  1425.         table = tup_exp(table, n + 1);
  1426.         for (i = n; i > 0; i--)
  1427.             table[i + 1] = table[i];
  1428.         tup = tup_new(2);
  1429.         tup[1] = (char *)(n + 1);
  1430.         tup[2] = (char *) 0;
  1431.         table[1] = (char *) tup;
  1432.         ntable = tup_new(n+1);
  1433.         /* table := [ [#table+1, 0] ] + table; */
  1434.         if (others_body != OPT_NODE) {
  1435.             index = 0;
  1436.             /* bodies := [others_body]+bodies; */
  1437.             n = tup_size(bodies);
  1438.             bodies = tup_exp(bodies, n + 1);
  1439.             for (i = n; i > 0; i--)
  1440.                 bodies[i + 1] = bodies[i];
  1441.             bodies[1] = (char *) others_body;
  1442.         }
  1443.         else {
  1444.             index = 1;
  1445.             /* The SETL version mixes quadruples and pairs in the tuple
  1446.              * table. Here we keep all quadruples in another tuple ntable; 
  1447.              * table := * [ [a, if b = 0 then [0, -1, -1] else b end]: [a, b]
  1448.              * in table ];
  1449.              */
  1450.             FORTUPI(tup = (Tuple), table, i, ft1);
  1451.                 b = (int) tup[2];
  1452.                 if (b == 0) {
  1453.                     tup4 = tup_new(4);
  1454.                     tup4[1] = tup[1];
  1455.                     tup4[2] = (char *) 0;
  1456.                     tup4[3] = (char *) - 1;
  1457.                     tup4[4] = (char *) - 1;
  1458.                     ntable[i] = (char *) tup4;
  1459.                 }
  1460.             ENDFORTUP(ft1);
  1461.         }
  1462.  
  1463.         /*  to allow overlapping of variants: */
  1464.         save_field_offset = max_field_offset = CURRENT_FIELD_OFFSET;
  1465.         /*  process each variant */
  1466.         while(tup_size(bodies) != 0) {
  1467.             CURRENT_FIELD_OFFSET = save_field_offset;
  1468.             first_field = CURRENT_FIELD_NUMBER;
  1469.  
  1470.             alt_node = (Node) tup_fromb(bodies);
  1471.             f_node = N_AST1(alt_node);
  1472.             v_node = N_AST2(alt_node);
  1473.             f_part = tup_new(0);
  1474.             FORTUP(node = (Node), N_LIST(f_node), ft1);
  1475.                 id_list_node = N_AST1(node);
  1476.                 /* f_part        +:= [ N_UNQ(n) : n in N_LIST(id_list_node)]; */
  1477.                 FORTUP(n_sym = (Node), N_LIST(id_list_node), ft2);
  1478.                     f_part = tup_with(f_part, (char *) N_UNQ(n_sym));
  1479.                 ENDFORTUP(ft2);
  1480.             ENDFORTUP(ft1);
  1481.             v_index = linearize_record(f_part, v_node);
  1482.             /* case_range := [first_field, first_field+#f_part-1, v_index]; */
  1483.             case_range = tup_new(3);
  1484.             case_range[1] = (char *) first_field;
  1485.             case_range[2] = (char *)(first_field + tup_size(f_part) - 1);
  1486.             case_range[3] = (char *) v_index;
  1487.             /* table := 
  1488.              * [ [a, if b = index then case_range else b end]: [a, b] in
  1489.              * table ]; 
  1490.              */
  1491.             FORTUPI(tup = (Tuple), table, i, ft1);
  1492.                 b = (int) tup[2];
  1493.                 if (b == index) {
  1494.                     tup4 = tup_new(4);
  1495.                     tup4[1] = tup[1];
  1496.                     tup4[2] = case_range[1];
  1497.                     tup4[3] = case_range[2];
  1498.                     tup4[4] = case_range[3];
  1499.                     ntable[i] = (char *) tup4;
  1500.                 }
  1501.             ENDFORTUP(ft1);
  1502.             if (max_field_offset < CURRENT_FIELD_OFFSET) {
  1503.                 max_field_offset = CURRENT_FIELD_OFFSET;
  1504.             }
  1505.             index += 1;
  1506.         }
  1507.         CURRENT_FIELD_OFFSET = max_field_offset;
  1508.         variant_offset = segment_get_maxpos(VARIANT_TABLE);
  1509.         /* VARIANT_TABLE       +:= [FIELD_NUMBER(name)]
  1510.          *               +/[ [a, b, c, d]: [a, [b, c, d]] in table ];
  1511.          */
  1512.  
  1513.         /* this code was added because of a test like :
  1514.          *
  1515.          *   type x (a, b : integer) is record
  1516.          *      case a is ...
  1517.          *        when others =>
  1518.          *   case b is
  1519.          *              when others => ...;
  1520.          *           end case;
  1521.          *      end case;
  1522.          *   end record;
  1523.          *
  1524.          *  The inner case does not refer explictly to "b". Therefore in the
  1525.          *  tree its name is not set. In this  case "name" is null. On acf2,
  1526.          *  the generated value for FIELD_NUMBER (name) was anything. On lang1
  1527.          *  there was an internal error (null pointer dereference). 
  1528.          *  Now in this case, the value is set to 0
  1529.          */
  1530.  
  1531.         if (name == (Symbol) 0) {
  1532.             segment_put_int(VARIANT_TABLE, 0);
  1533.         }
  1534.         else {
  1535.             segment_put_int(VARIANT_TABLE, (int)FIELD_NUMBER(name));
  1536.         }
  1537.         FORTUP(tup = (Tuple), ntable, ft1);
  1538.             segment_put_int(VARIANT_TABLE, (int) tup[1]);
  1539.             segment_put_int(VARIANT_TABLE, (int) tup[2]);
  1540.             segment_put_int(VARIANT_TABLE, (int) tup[3]);
  1541.             segment_put_int(VARIANT_TABLE, (int) tup[4]);
  1542.         ENDFORTUP(ft1);
  1543.         return variant_offset;
  1544.     }
  1545.     else {
  1546.         return - 1;        /* = no variant part */
  1547.     }
  1548. }
  1549.  
  1550. static int discr_dep_subtype(Node decl)                    /*;discr_dep_subtype*/
  1551. {
  1552.     /*
  1553.      *   This procedure takes care of the special type templates
  1554.      *   used for subtypes whose constraints depends on the discriminants
  1555.      *   of the enclosing record.
  1556.      *
  1557.      *   The templates produced are TT_D_RECORD and TT_D_ARRAY.
  1558.      *
  1559.      *   return TRUE in that case, FALSE if not a discr_dep_subtype.
  1560.      */
  1561.  
  1562.     Node id_node, low, high, lbd, ubd, de, discr_value_node;
  1563.     Symbol type_name, type_mark, indx_type, discr_type, comp_type, field_name;
  1564.     Tuple constraint, tup, index_list, field_map, discr_list;
  1565.     int     varying_size_flag, max_nb_elem, nb_dim, tsize, i, n;
  1566.     Fortup ft1;
  1567.     Const min_low, max_high;
  1568.     Segment stemplate;
  1569.     int discr_depends, discr_value; /* used for get_discr values */
  1570.     struct tt_d_type   *tt_d_type_ptr;
  1571.  
  1572. #ifdef TRACE
  1573.     if (debug_flag)
  1574.         gen_trace_node("DISCR_DEP_SUBTYPE", decl);
  1575. #endif
  1576.  
  1577.     id_node = N_AST1(decl);
  1578.     type_name = N_UNQ(id_node);
  1579.     type_mark = base_type(type_name);
  1580.     constraint = get_constraint(type_name);
  1581.     varying_size_flag = FALSE;
  1582.     stemplate = (Segment) 0;
  1583.  
  1584.     switch((int) constraint[1]) {
  1585.  
  1586.     case(co_access):
  1587.         INTERNAL_ACCESSED_TYPES = tup_with(INTERNAL_ACCESSED_TYPES,
  1588.           (char *) DESIGNATED_TYPE(type_name));
  1589.         compile(decl);
  1590.         return FALSE;
  1591.  
  1592.     case(co_index):
  1593.         tup = SIGNATURE(type_name);
  1594.         index_list = (Tuple) tup[1];
  1595.         comp_type = (Symbol) tup[2];
  1596.         max_nb_elem = 1;
  1597.         FORTUP(indx_type = (Symbol), index_list, ft1);
  1598.             tup = SIGNATURE(indx_type);
  1599.             low = (Node) tup[2];
  1600.             high = (Node) tup[3];
  1601.             if (is_discr_ref(low)) {
  1602.                 varying_size_flag = TRUE;
  1603.                 discr_type = N_TYPE(low);
  1604.                 tup = SIGNATURE(discr_type);
  1605.                 low = (Node) tup[2];
  1606.             }
  1607.             if (is_discr_ref(high)) {
  1608.                 varying_size_flag = TRUE;
  1609.                 discr_type = N_TYPE(high);
  1610.                 tup = SIGNATURE(discr_type);
  1611.                 high = (Node) tup[3];
  1612.             }
  1613.             min_low = get_ivalue(low);
  1614.             max_high = get_ivalue(high);
  1615.             if (max_nb_elem >= 0
  1616.               && min_low->const_kind != CONST_OM
  1617.               && max_high->const_kind != CONST_OM) {
  1618.                 max_nb_elem *= get_ivalue_int(high) - get_ivalue_int(low) + 1;
  1619.             }
  1620.             else {
  1621.                 max_nb_elem = -1;
  1622.             }
  1623.         ENDFORTUP(ft1);
  1624.         if (!varying_size_flag) {
  1625.             compile(decl);
  1626.             return FALSE;
  1627.         }
  1628.         nb_dim = tup_size(index_list);
  1629.         tsize = TYPE_SIZE(comp_type);
  1630.         TYPE_SIZE(type_name) = (max_nb_elem < 0 || tsize < 0) ? -1
  1631.           : max_nb_elem * tsize;
  1632.         TYPE_KIND(type_name) = TT_D_ARRAY;
  1633.  
  1634.         reference_of(type_mark);
  1635.         /* template        := [TT_D_ARRAY, size_of(type_name)]+ref+[nb_dim]; */
  1636.         stemplate = template_new(TT_D_ARRAY, size_of(type_name),
  1637.           WORDS_D_TYPE, TT_PTR(&tt_d_type_ptr));
  1638.         tt_d_type_ptr->dbase = REFERENCE_SEGMENT;
  1639.         tt_d_type_ptr->doff = REFERENCE_OFFSET;
  1640.         tt_d_type_ptr->nb_discr_d = nb_dim;
  1641.  
  1642.         FORTUP(indx_type = (Symbol), index_list, ft1);
  1643.             tup = SIGNATURE(indx_type);
  1644.             low = (Node) tup[2];
  1645.             high = (Node) tup[3];
  1646.             /* template +:= get_discr(low);  template +:= get_discr(high); */
  1647.             get_discr(low, &discr_depends, &discr_value);
  1648.             segment_put_int(stemplate, discr_depends);
  1649.             segment_put_int(stemplate, discr_value);
  1650.             get_discr(high, &discr_depends, &discr_value);
  1651.             segment_put_int(stemplate, discr_depends);
  1652.             segment_put_int(stemplate, discr_value);
  1653.         ENDFORTUP(ft1);
  1654.         break;
  1655.  
  1656.     case(co_discr):
  1657.         field_map = (Tuple) constraint[2];
  1658.         n = tup_size(field_map);
  1659.         for (i = 1; i <= n; i += 2) {
  1660.             de = (Node) field_map[i+1];
  1661.             varying_size_flag |= is_discr_ref(de);
  1662.         }
  1663.  
  1664.         if (!varying_size_flag) {
  1665.             compile(decl);
  1666.             return FALSE;
  1667.         }
  1668.         TYPE_KIND(type_name) = TT_D_RECORD;
  1669.         TYPE_SIZE(type_name) = TYPE_SIZE(type_mark);
  1670.         /* template := [TT_D_RECORD, size_of(type_name)]+ref+[#field_map]; */
  1671.         stemplate = template_new(TT_D_RECORD, size_of(type_name),
  1672.           WORDS_D_TYPE, TT_PTR(&tt_d_type_ptr));
  1673.         reference_of(type_mark);
  1674.         tt_d_type_ptr->dbase = REFERENCE_SEGMENT;
  1675.         tt_d_type_ptr->doff = REFERENCE_OFFSET;
  1676.         /* In SETL, want number of entries in field map; in C, this
  1677.          * is number of entries in tuple used for for field map divided
  1678.          * by two, since two elements are required for each single entry
  1679.          * (domain and range values) in SETL version.
  1680.          */
  1681.         tt_d_type_ptr->nb_discr_d = tup_size(field_map) / 2;
  1682.         /* obtain discriminants in same order as in unconstrained type */
  1683.         tup = SIGNATURE(type_mark);
  1684.         discr_list = (Tuple) tup[3];
  1685.         FORTUP(field_name = (Symbol), discr_list, ft1);
  1686.             discr_value_node = discr_map_get(field_map, field_name);
  1687.             if (N_KIND (discr_value_node) == as_qual_range) {
  1688.                 N_TYPE (discr_value_node) = root_type(TYPE_OF (field_name));
  1689.             }
  1690.             /* template   +:= get_discr(discr_value); */
  1691.             get_discr(discr_value_node, &discr_depends, &discr_value);
  1692.             segment_put_int(stemplate, discr_depends);
  1693.             segment_put_int(stemplate, discr_value);
  1694.         ENDFORTUP(ft1);
  1695.         break;
  1696.  
  1697.     case(co_range):
  1698.         lbd = (Node) constraint[2];
  1699.         ubd = (Node) constraint[3];
  1700.         if (is_discr_ref(lbd) || is_discr_ref(ubd)) {
  1701.             /* can only be an anonymous type for an index of a TT_D_ARRAY
  1702.              * no explicit template built for it
  1703.              */
  1704.             break;
  1705.         }
  1706.         else {
  1707.             compile(decl);
  1708.         }
  1709.         return FALSE;
  1710.  
  1711.     default:
  1712.         return FALSE;
  1713.     }
  1714.     if (stemplate != (Segment) 0) {
  1715.         install_type(type_name, stemplate, FALSE);
  1716.     }
  1717.     return varying_size_flag;
  1718. }
  1719.  
  1720. static void get_discr(Node node, int *discr_depends, int *discr_value)
  1721.                                                                 /*;get_discr*/
  1722. {
  1723.     /* discr_depends and discr_value are used to return values corresponding
  1724.      * to use of tuple for SETL return value 
  1725.      */
  1726.  
  1727.     /*
  1728.      * if the expression depends on a discriminant, then returns
  1729.      *    [ 1, field number of the discriminant ]
  1730.      * otherwise return
  1731.      *    [ 0, value of the discriminant ]
  1732.      *
  1733.      */
  1734.  
  1735.     Symbol discr;
  1736.     int     fn;
  1737.  
  1738. #ifdef TRACE
  1739.     if (debug_flag)
  1740.         gen_trace_node("GET_DISCR", node);
  1741. #endif
  1742.  
  1743.     if (is_discr_ref(node)) {
  1744.         if (N_KIND(node) == as_qual_range)
  1745.             node = N_AST1(node);
  1746.         discr = N_UNQ(node);
  1747.         fn = (int) FIELD_NUMBER(discr);
  1748.         gen_kvc(I_PUSH_IMMEDIATE, mu_byte, int_const(fn), "discr. ref.");
  1749.         *discr_depends = TRUE;
  1750.         *discr_value = fn;
  1751.         return;
  1752.     }
  1753.     else {
  1754.         gen_value(node);
  1755.         *discr_depends = FALSE;
  1756.         *discr_value = 0;
  1757.         return;
  1758.     }
  1759. }
  1760.  
  1761. static void eval_max_size(Symbol type_name, Tuple discr_subtypes)
  1762.                                                             /*;eval_max_size*/
  1763. {
  1764.     Symbol discr, type_mark, comp_type, indx_type;
  1765.     int     discr_low, discr_high, fn;
  1766.     Node low_node, high_node;
  1767.     Tuple constraint, index_list, tup;
  1768.  
  1769. #ifdef TRACE
  1770.     if (debug_flag)
  1771.         gen_trace_symbol("EVAL_MAX_SIZE", type_name);
  1772. #endif
  1773.     if (size_of(type_name) != -1) {/* static, already evaluated */
  1774.         return;
  1775.     }
  1776.  
  1777.     type_mark = TYPE_OF(type_name);
  1778.     constraint = get_constraint(type_name);
  1779.  
  1780.     switch((int) constraint[1]) {
  1781.  
  1782.     case(co_access):
  1783.         break;
  1784.  
  1785.     case(co_index):
  1786.         comp_type = (Symbol) COMPONENT_TYPE(type_mark);
  1787.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  1788.         /* WORD_OFF is(obscure) macro defined in type.h to get
  1789.          * offset(in ints) to object_size field 
  1790.          */
  1791.         gen_kic(I_ADD_IMMEDIATE, mu_word, WORD_OFF(tt_i_range, object_size),
  1792.           "Object size");
  1793.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
  1794.         gen_kic(I_ADD_IMMEDIATE, mu_word, WORD_OFF(tt_i_range, object_size),
  1795.           "Compon. size");
  1796.         gen_k(I_DEREF, kind_of(symbol_integer));
  1797.         tup = INDEX_TYPES(type_name);
  1798.         index_list = tup_copy(tup);
  1799.         while(tup_size(index_list) != 0) {
  1800.             indx_type = (Symbol) tup_fromb(index_list);
  1801.             tup = SIGNATURE(indx_type);
  1802.             low_node = (Node) tup[2];
  1803.             high_node = (Node) tup[3];
  1804.             discr_low = is_discr_ref(low_node);
  1805.             discr_high = is_discr_ref(high_node);
  1806.             if (!(discr_low | discr_high)) {
  1807.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, indx_type);
  1808.                 gen_kv(I_ATTRIBUTE, ATTR_T_LENGTH, int_const(0));
  1809.             }
  1810.             else {
  1811.                 if (discr_high) {
  1812.                     if (N_KIND(high_node) == as_qual_range)
  1813.                         high_node = N_AST1(high_node);
  1814.                     discr = N_UNQ(high_node);
  1815.                     fn = (int) FIELD_NUMBER(discr) + 1;
  1816.                     /* field # start from 0 */
  1817.                     if (base_type (indx_type) == ((Symbol) discr_subtypes [fn]))
  1818.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, TYPE_OF(indx_type));
  1819.                     else
  1820.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  1821.                           (Symbol) discr_subtypes[fn]);
  1822.                     gen_kv(I_ATTRIBUTE, ATTR_T_LAST, int_const(0));
  1823.                 }
  1824.                 else {
  1825.                     if (base_type (indx_type) == (N_TYPE (high_node)))
  1826.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, TYPE_OF(indx_type));
  1827.                     else
  1828.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, N_TYPE (high_node));
  1829.                     gen_kv(I_ATTRIBUTE, ATTR_T_LAST, int_const(0));
  1830.                 }
  1831.                 if (discr_low) {
  1832.                     if (N_KIND(low_node) == as_qual_range)
  1833.                         low_node = N_AST1(low_node);
  1834.                     discr = N_UNQ(low_node);
  1835.                     fn = (int) FIELD_NUMBER(discr) + 1;
  1836.                     /* field # start from 0 */
  1837.                     if (base_type (indx_type) == ((Symbol) discr_subtypes [fn]))
  1838.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, TYPE_OF(indx_type));
  1839.                     else
  1840.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS,
  1841.                           (Symbol) discr_subtypes[fn]);
  1842.                     gen_kv(I_ATTRIBUTE, ATTR_T_FIRST, int_const(0));
  1843.                 }
  1844.                 else {
  1845.                     if (base_type (indx_type) == (N_TYPE (low_node)))
  1846.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, TYPE_OF(indx_type));
  1847.                     else
  1848.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, N_TYPE (low_node));
  1849.                     gen_kv(I_ATTRIBUTE, ATTR_T_FIRST, int_const(0));
  1850.                 }
  1851.                 gen_k(I_SUB, kind_of(symbol_integer));
  1852.                 gen_ki(I_ADD_IMMEDIATE, kind_of(symbol_integer), 1);
  1853.             }
  1854.             gen_k(I_MUL, kind_of(symbol_integer));
  1855.         }
  1856.         gen_kc(I_MOVE, mu_word, "update tt size");
  1857.         break;
  1858.  
  1859.     case(co_discr):
  1860.         break;        /* should be no problem as the TT_D_RECORD is
  1861.                            constrained */
  1862.  
  1863.     case(co_range):
  1864.         break;
  1865.     }
  1866. }
  1867.